home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / test / trapezoid.l
Lisp/Scheme  |  1988-09-12  |  2KB  |  73 lines
  1. ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3. ;;; CLX trapezoid Extension test program
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. (in-package 'xlib :use '(lisp))
  22.  
  23.  
  24. (defun zoid-test (host)
  25.   ;; Display the part picture in /extensions/test/datafile
  26.   (let* ((display (open-display host))
  27.      (width 400)
  28.      (height 400)
  29.      (screen (display-default-screen display))
  30.      (black (screen-black-pixel screen))
  31.      (white (screen-white-pixel screen))
  32.      (win (create-window
  33.         :parent (screen-root screen)
  34.         :background black
  35.         :border white
  36.         :border-width 1
  37.         :colormap (screen-default-colormap screen)
  38.         :bit-gravity :center
  39.         :event-mask '(:exposure :key-press)
  40.         :x 20 :y 20
  41.         :width width :height height))
  42.      (gc (create-gcontext
  43.            :drawable win
  44.            :background black
  45.            :foreground white)))
  46.     (initialize-extensions display)
  47.     
  48.     (map-window win)                ; Map the window
  49.     ;; Handle events
  50.     (unwind-protect
  51.     (loop
  52.       (event-case (display :force-output-p t)
  53.         (exposure  ;; Come here on exposure events
  54.           (window count)
  55.           (when (zerop count) ;; Ignore all but the last exposure event
  56.         (clear-area window)
  57.         ;; NOT VERY INTERESTING, BUT CHECKS ALL THE POSSIBILITIES
  58.         (poly-fill-Trapezoids window gc  '(10 20 30 40 100 200))
  59.         (setf (gcontext-trapezoid-alignment gc) :y)
  60.         (poly-fill-Trapezoids window gc  #(10 20 30 40 100 200))
  61.         (with-gcontext (gc :trapezoid-alignment :x)
  62.           (poly-fill-Trapezoids window gc  '(40 50 60 70 140 240)))
  63.         (setf (gcontext-trapezoid-alignment gc) :x)
  64.         (poly-fill-Trapezoids window gc  #(40 50 60 70 80 90))
  65.         (with-gcontext (gc :trapezoid-alignment :y)
  66.           (poly-fill-Trapezoids window gc  #(40 50 60 70 140 240)))
  67.           
  68.         (draw-glyphs window gc 10 10 "Press any key to exit")
  69.         ;; Returning non-nil causes event-case to exit
  70.         t))
  71.         (key-press () (return-from zoid-test t))))
  72.       (close-display display))))
  73.